home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / GRAPHICS.SWG / 0089_Plasma.pas < prev    next >
Pascal/Delphi Source File  |  1994-05-25  |  7KB  |  225 lines
  1. {
  2. This is my plasma code. Written here for windows 24bit mode. There's
  3. some comments in it. It had a problem. I tried to fix it. Couldn't.
  4. Deleted some POSITIVELY ABSOLUTELY ESSENTIAL bits of code, and the
  5. problem went away. Don't ask me, I just wrote it.
  6.  
  7. You should be able to put it to palette based code pretty easy. It
  8. started out that way and then got converted to RGB. Probably all you'd
  9. need to do, is kill red and green, and just use blue as the palette
  10. entry. Your problem to make sure your palette has nice colours.
  11.  
  12. It still tends to be a little ridgy on the primary axes. If anybody can
  13. get rid of that, that would be cool. Let me know.
  14.  
  15. It's also a fractal terrain generator. Same alg. This is just 3 fractal
  16. terrain altitude maps overlaid in rgb.
  17.  
  18. (Oh, yeah, it's not really windows code. All the real windows code
  19. should be separate from the useful code, just in case you don't do
  20. windows, don't be scared.)
  21.  
  22. --8<--------------------------------------------------------
  23. }
  24.  
  25. program plasma;
  26. {integer version of cloud.
  27.  Only works 24bit. Change resolution
  28.  constants width, height if you need.}
  29. {Left button starts drawing.
  30.  CTRL-ALT-DEL to stop. Or wait for it to finish, and
  31.  right button}
  32. uses OWindows, ODialogs, WinTypes, WinProcs;
  33.  
  34. const
  35. {integer version of old real constant.
  36.  For calm versions, try FUZZ1/FUZZ2=0.3
  37.  For wild versions, try FUZZ1/FUZZ2=10}
  38.   FUZZ1=1;
  39.   FUZZ2=6;
  40.  
  41.   width= 800;
  42.   height= 600;
  43.  
  44. type
  45.      TMyApp=object (TApplication)
  46.        procedure InitMainWindow; virtual;
  47.        end;
  48.  
  49.      PMyWindow=^TPlasmaWindow;
  50.      TPlasmaWindow=object (TWindow)
  51.        r,g,b:byte;
  52.        w,h:integer;
  53.        constructor init(AParent:PWindowsObject; ATitle:PChar);
  54.        procedure SetUpWindow; virtual;
  55.        procedure WMLButtonDown(var Msg:TMessage); virtual wm_First+wm_LButtonDown;
  56.        procedure WMRButtonDown(var Msg:TMessage); virtual wm_First+wm_RButtonDown;
  57.        function getclassname:pchar; virtual;
  58.        procedure getwindowclass(var awndclass:twndclass); virtual;
  59.        end;
  60.  
  61. var maxx,maxy:integer;
  62.     backg:TColorRef;
  63.     i:integer;
  64.  
  65. function clamp(x:integer):byte;
  66. begin
  67. {  if x<0 then x:=0
  68.   else if x>255 then x:=255;
  69.   clamp:=x;}
  70.   case x of
  71.    -32767..0 : clamp:=0;
  72.    0..255    : clamp:=x;
  73.    256..32767: clamp:=255;
  74.    else {oops};
  75.    end; {case}
  76. end;
  77.  
  78. function randomcolour:TColorRef;
  79. var r,g,b:byte;
  80. begin
  81.     randomcolour:=rgb(random(256),random(256),random(256));
  82. end;
  83.  
  84. procedure TMyApp.InitMainWindow;
  85. begin
  86.    MainWindow := New(PMyWindow, Init(NIL,'Plasma'));
  87. end;
  88.  
  89. constructor TPlasmaWindow.init(AParent:PWindowsObject; ATitle:PChar);
  90. begin
  91.   inherited init(AParent,ATitle);
  92.   r:=0; g:=0; b:=0;
  93.   w:=2;h:=2;
  94.   attr.x:=0; attr.y:=0;
  95.   attr.w:=width; attr.h:=height;
  96.   attr.style:=ws_popup + ws_visible;
  97. end;
  98.  
  99. procedure TPlasmaWindow.SetUpWindow;
  100. begin
  101.   inherited setupwindow;
  102. end;
  103.  
  104. procedure TPlasmaWindow.WMLButtonDown(var Msg:TMessage);
  105. var ADC:HDC;
  106.     AP,TempP:HPen;
  107.     AB,TempB:HBrush;
  108.  
  109.     function max(a,b:integer):integer;
  110.     begin
  111.       if a<b then        max:=b      else        max:=a;
  112.     end;
  113.  
  114.     function mid(a,b:integer):integer;
  115.     begin
  116.       mid:=(a + b) div 2;
  117.     end;
  118.  
  119.     function ridge(a,b,c,d:integer):TColorref;
  120.     {Take two endpoints, shift the mid point, based on how far apart they are.}
  121.     var variance:integer;
  122.         r,g,l:byte;
  123.         m,n:TColorref;
  124.         vd2:integer;
  125.     begin
  126.       variance:=max(c-a,d-b) * FUZZ1 div FUZZ2;
  127.       vd2:=variance div 2;
  128.       m:=getpixel(adc,(a),(b));
  129.       n:=getpixel(adc,(c),(d));
  130.       r:=clamp(((getrvalue(m) + getrvalue(n)) div 2{ + (random(variance))-vd2}));
  131.       g:=clamp(((getgvalue(m) + getgvalue(n)) div 2{ + (random(variance))-vd2}));
  132.       l:=clamp(((getbvalue(m) + getbvalue(n)) div 2{ + (random(variance))-vd2}));
  133.       ridge:=rgb(r,g,l);
  134.     end;
  135.  
  136.     function shift(a,b,c,d:integer; col:tcolorref):tcolorref;
  137.     var variance:integer;
  138.         r,g,l:byte;
  139.         vd2:integer;
  140.     begin
  141. {      variance:=max(d-b,c-a) * FUZZ1 div FUZZ2;}
  142.       variance:=(c-a) * FUZZ1 div FUZZ2;
  143.       vd2:=variance div 2;
  144.       r:=clamp(getrvalue(col) + (random(variance))-vd2);
  145.       g:=clamp(getgvalue(col) + (random(variance))-vd2);
  146.       l:=clamp(getbvalue(col) + (random(variance))-vd2);
  147.       shift:=rgb(r,g,l);
  148.     end;
  149.  
  150.     procedure quarter(l,t,r,b:integer);
  151.     var mx,my,width,colour,variance:integer;
  152.         mzr,mzg,mzb:byte;
  153.         c:char;
  154.         m,n,o,p,tc:TColorRef;
  155.         vd2:integer;
  156.         abrush:hbrush;
  157.     begin
  158.       width:=r-l;
  159.       if (width>1) or (b-t>1) then
  160.         begin
  161.         variance:=width * FUZZ1 div fuzz2 ;
  162.         vd2:=variance div 2;
  163.         mx:=mid(l,r);
  164.         my:=mid(t,b);
  165.         m:=getpixel(adc,l,t);
  166.         n:=getpixel(adc,l,b);
  167.         o:=getpixel(adc,r,t);
  168.         p:=getpixel(adc,r,b);
  169.         mzr:=clamp((getrvalue(m) + getrvalue(n) + getrvalue(o) + getrvalue(p)) div 4 + random(variance)-vd2);
  170.         mzg:=clamp((getgvalue(m) + getgvalue(n) + getgvalue(o) + getgvalue(p)) div 4 + random(variance)-vd2);
  171.         mzb:=clamp((getbvalue(m) + getbvalue(n) + getbvalue(o) + getbvalue(p)) div 4 + random(variance)-vd2);
  172.  
  173.         setpixel(adc,mx,my,rgb(mzr,mzg,mzb));
  174.         setpixel(adc,(l),(my),ridge(l,t,l,b));
  175.         setpixel(adc,(r),(my),ridge(r,t,r,b));
  176.         setpixel(adc,(mx),(t),ridge(l,t,r,t));
  177.         setpixel(adc,(mx),(b),ridge(l,b,r,b));
  178.  
  179.         quarter(l,t,mx,my);
  180.         quarter(l,my,mx,b);
  181.         quarter(mx,t,r,my);
  182.         quarter(mx,my,r,b);
  183.         end;
  184.     end;
  185.  
  186. begin
  187.   ADC:=getdc(HWindow);
  188.   randomize;
  189.   maxx:=width-1; maxy:=height-1;
  190.   backg:=getpixel(ADC,10,10);
  191.   setpixel(adc,0,0,randomcolour);
  192.   setpixel(adc,0,maxy,randomcolour);
  193.   setpixel(adc,maxx,0,randomcolour);
  194.   setpixel(adc,maxx,maxy,randomcolour);
  195.   setpixel(adc,mid(0,maxx),0,randomcolour);
  196.   setpixel(adc,mid(0,maxx),maxy,randomcolour);
  197.   setpixel(adc,0,mid(0,maxy),randomcolour);
  198.   setpixel(adc,maxx,mid(0,maxy),randomcolour);
  199.   quarter(0,0,maxx,maxy);
  200.   end;
  201.  
  202. procedure TPlasmaWindow.WMRButtonDown(var Msg:TMessage);
  203. begin
  204.   destroy;
  205. end;
  206.  
  207. function TPlasmaWindow.getclassname:pchar;
  208. begin
  209.   getclassname:='Cloud Window';
  210. end;
  211.  
  212. procedure TPlasmaWindow.getwindowclass(var awndclass:twndclass);
  213. begin
  214.   inherited getwindowclass(awndclass);
  215.   awndclass.hbrbackground:=getstockobject(white_brush);
  216. end;
  217.  
  218. var DitherApp:TMyApp;
  219.  
  220. begin
  221.   DitherApp.init('Cloud');
  222.   DitherApp.run;
  223.   DitherApp.done;
  224. end.
  225.